Shareware Super Platinum 8

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / DATABASE / BORUSR2.ZIP;1 / PROC.PRG < prev next >

Wrap

Text File | 1992-07-06 | 62.9 KB | 1,637 lines

*-- PROGRAM.....: PROC.PRG ** Version of the PROC.PRG file from the soon to be released LIB16.ZIP set ** of procedure/library files. This has had several routines modified to ** take advantage of "explicit color setting" ... bypassing a known problem ** in dBASE IV, 1.5. Added the mouse drivers here, as well. 06/09/1992 ** (A few more additions ... Jay's RECOLOR(), COLOROF(), my COLORBRK(), and ** Keith's VPICK() ... Joey's PROGBAR some nice stuff all on/around: 06/29/1992) *------------------------------------------------------------------------------- *-- Programmer..: Kenneth J. Mayer, (KENMAYER on BORBBS) *-- Date........: 06/29/1992 *-- Version.....: 2.6 -- See WHATS.NEW and README.TXT files (both ASCII), *-- both files uploaded to BORBBS with this file in one *-- zipped file. *-- Notes.......: This procedure file is part of the new and improved set of *-- files, re-designed for dBASE IV, 1.7. The complete set is *-- contained in the file: LIB16.ZIP. Please read README.TXT *-- for all instructions. *=============================================================================== *=============================================================================== * MESSAGE/SCREEN PROCESSING ROUTINES -- includes message boxes, shadowing, * and centering of text ... Anything not here is in the library file: * SCREEN.PRG. *=============================================================================== PROCEDURE PrintErr *------------------------------------------------------------------------------- *-- Programmer..: Ken Mayer (KENMAYER) *-- Date........: 05/24/1991 *-- Notes.......: Used to display a printer error for STAND-ALONE *-- systems. (The dBASE function PRINTSTATUS() doesn't work *-- well on a Network with Print Spoolers ...) *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: SHADOW Procedure in PROC.PRG *-- CENTER Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: do printerr *-- Example.....: do setprint && if it hasn't been done *-- if .not. printstatus() *-- DO PRINTERR *-- endif *-- * or *-- do while .not. printstatus() && my preference ... loop! *-- DO PRINTERR *-- enddo *-- Returns.....: None *-- Parameters..: None *------------------------------------------------------------------------------- private cColor, cDummy, cCursor if iscolor() && if we're using a color monitor, use yellow on red cColor = "RG+/R,RG+/R,RG+/R" else && otherwise, use black on white cColor = "N/W,N/W,N/W" endif define window wPErr from 7,15 to 16,57 double color &cColor save screen to sPErr && store current screen do shadow with 7,15,16,57 && shadow box! activate window wPErr && here we go .. cCursor=set("CURSOR") && save cursor setting set cursor off && turn cursor off && display message do center with 0,40,"",chr(7) + "*** PRINTER ERROR ***" do center with 2,40,""," The printer is not ready. Please check:" do center with 3,40,"","1) that the printer is ON, " do center with 4,40,"","2) that the printer is ONLINE, and" do center with 5,40,"","3) that the printer has paper. " do center with 7,40,"","Press any key to continue . . ." cDummy=inkey(0) && wait for user to press a key ... set cursor &cCursor && set cursor to original setting ... deactivate window wPErr && cleanup release window wPErr restore screen from sPErr release screen sPErr RETURN *-- EoP: PrintErr PROCEDURE Open_Screen *------------------------------------------------------------------------------- *-- Programmer..: Rick Price (HAMMETT) *-- Date........: 05/24/1991 *-- Notes.......: Used to give a texture to the background of the screen *-- I got this from Rick when he uploaded it as part of his *-- original entry to a Color Contest on the ATBBS. It is *-- kinda nice to have that texture on the screen, keeps it *-- from being monotonous. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do open_screen *-- Example.....: do open_screen *-- Returns.....: None *-- Parameters..: None *------------------------------------------------------------------------------- private nRow, cBackDrp, nHoldRow clear nRow=0 cBackdrp = chr(176) && chr(176) = "∞", chr(177) = "±", chr(178) = "≤" do while nRow < 3 @nRow,0 to nRow+3,79 cBackdrp && fill this section of the screen nHoldRow = nRow nRow = nRow + 6 @nRow,0 to nRow+3,79 cBackdrp nRow = nRow + 6 @nRow,0 to nRow+3,79 cBackdrp nRow = nRow + 6 @nRow,0 to nRow+3,79 cBackdrp nRow = nHoldRow + 1 enddo @24,0 to 24,79 cBackdrp RETURN *-- EoP: OpenScreen PROCEDURE JazClear *------------------------------------------------------------------------------- *-- Programmer..: Rick Price (HAMMETT) *-- Date........: 05/24/1991 *-- Notes.......: Used to clear the screen from the middle out -- *-- could be used with OpenScreen, above. I got this *-- from Rick at the same time I got the other routine above ... *-- This requires a full screen (0,0 to 23,79 ...) *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do jazclear *-- Examples....: do jazclear *-- Returns.....: None *-- Parameters..: None *------------------------------------------------------------------------------- private nWinR1, nWinR2, nWinC1, nWinC2, nStep, mnWinC1, mnWinC2, ; mnWinR1, mnWinR2, nStep, nTmpAdjR, nTmpAdjC, nAdjRow, nAdjCol private nColLeft, nColRite, nRowTop, nRowBot nWinR1 = 0 && row 1 nWinR2 = 24 && row 2 nWinC1 = 0 && column 1 nWinC2 = 79 && column 2 nStep = 1 && amount to increment by * set starting point mnWinC1 = int((nWinC2-nWinC1)/2)+nWinC1 mnWinC2 = mnWinC1+1 mnWinR1 = int((nWinR2-nWinR1)/2)+nWinR1 mnWinR2 = mnWinR1+1 ** Adjust step offset values: nColOff & nRowOff ** Vertical steps: nWinR1-nWinR1 nTmpAdjR = int((nWinR2 - nWinR1)/2) nTmpAdjC = int((nWinC2 - nWinC1)/2) nAdjRow = ; iif(nTmpAdjC > nTmpAdjR, nTmpAdjR/nTmpAdjC,1) * nStep nAdjCol = ; iif(nTmpAdjR > nTmpAdjC, nTmpAdjC/nTmpAdjR,1) * nStep ncolleft = nWinC1 ncolrite = nWinC2 nRowTop = nWinR1 nRowBot = nWinR2 nWinC1 = mnWinC1 nWinC2 = mnWinC2 nWinR1 = mnWinR1 nWinR2 = mnWinR2 do while (nWinC1#nColLeft .or. nWinC2#nColRite .or. ; nWinR1 # nRowTop .or. nWinR2 # nRowBot) * Adjust coordinates for the clear (moving out from the middle) nWinR1 = ; nWinR1-iif(nRowTop<nWinR1-nAdjRow,nAdjRow,nWinR1-nRowTop) nWinR2 = ; nWinR2+iif(nRowBot>nWinR2+nAdjRow,nAdjRow,nRowBot-nWinR2) nWinC1 = ; nWinC1-iif(nColLeft<nWinC1-nAdjCol,nAdjCol,nWinC1-nColLeft) nWinC2 = ; nWinC2+iif(nColRite>nWinC2+nAdjCol,nAdjCol,nColRite-nWinC2) * Perform the clear @nWinR1,nWinC1 clear to nWinR2,nWinC2 @nWinR1,nWinC1 to nWinR2,nWinC2 enddo clear RETURN *-- EoP: JazClear PROCEDURE Center *------------------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 05/24/1991 *-- Notes.......: Centers text on the screen with @says *-- Written for.: dBASE IV, 1.1 *-- Rev. History: This and all other procedures/functions listed in this *-- file attributed to Miriam Liskin came from "Liskin's *-- Programming dBASE IV Book". Very good, worth the money. *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do center with <nLine>,<nWidth>,"<cColor>","<cText>" *-- Example.....: do center with 5,65,"RG+/GB","WARNING! This will blow up!" *-- Note that the color field may be blank: "" *-- Returns.....: None *-- Parameters..: nLine = Line or Row for @/Say *-- nWidth = Width of screen *-- cColor = Colors to be used ("Forg/Back") (may be nul "", in *-- order to use the default colors of window/screen) *-- cText = Message to center on screen *------------------------------------------------------------------------------- parameters nLine,nWidth,cColor,cText private nCol nCol = (nWidth - len(cText)) /2 @nLine,nCol say cText color &cColor. RETURN *-- EoP: Center FUNCTION Surround *------------------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 05/24/1991 *-- Notes.......: Displays a message surrounded by a box anywhere on *-- the screen *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (KENMAYER) to a function *-- from original procedure *-- Calls.......: None *-- Called by...: Any *-- Usage.......: surround(<nLine>,<nColumn>,"<cColor>","<cText>") *-- Example.....: cDummy = surround(5,12,"RG+/GB",; *-- "Processing ... Do not Touch!") *-- Returns.....: Nul/"" *-- Parameters..: nLine = Line to display "surrounded" message at *-- nColumn = Column for same (X,Y coordinates for @SAY) *-- cColor = Color variable/colors *-- cText = Text to be displayed inside box *------------------------------------------------------------------------------- parameters nLine,nColumn,cColor,cText cText = " " + trim(cText) + " " && add spaces around text @nLine-1,nColumn-1 to nLine+1,nColumn+len(cText) double; color &cColor. && draw box @nLine,nColumn say cText color &cColor. && disp. text RETURN "" *-- EoF: Surround() PROCEDURE ProgBar *------------------------------------------------------------------------------- *-- Programmer..: Joey D. Carroll (JOEY) *-- Date........: 06/28/1992 *-- Notes.......: A visual indicator of program activity, i.e. shows *-- user program didn't die during long processes which *-- do not normally show 'on screen'. Serves same purpose *-- as MONITOR, but is more graphic. *-- For best appearance, set cursor 'off' from calling *-- program, outside of the loop which calls PROGBAR. *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do PROGBAR with <nQuan>,<cWindCol>,<cFillCol1>,cFillCol2>, ; *-- <cMessage>,<nWindWidth> *-- Example.....: *-- determine what process will be monitored and what the *-- *-- final value will be, e.g. nReccount = reccount() *-- use <anyfile> *-- nReccount = reccount() *-- set cursor off *-- scan *-- do progbar with nReccount,",,w+/n","w+/r","w+/g", ; *-- "Processing records. Be patient.",40 *-- *-- do some needed process here *-- endscan *-- *-- cleanup *-- Returns.....: None *-- Parameters..: nQuan = maximum number of iterations *-- cWindCol = the window colors *-- cFillCol1 = color of ruler before process *-- cFillCol2 = color of ruler after process *-- cMessage = message displayed to user, may be "". *-- nWindWid = (optional) desired width of ruler window. If *-- not specified, width of screen. If *-- specified, will not be less than length of *-- message. *------------------------------------------------------------------------------- parameters nQuan,cWindCol,cFillCol1,cFillCol2,cMessage,nWindWidth private lMessage,x lMessage = iif(.not. isblank(cMessage), .t., .f.) && was message passed? *-- find out # of parameters passed ... if val(right(version(),3)) > 1.1 nParms = pcount() else nParms = 6 endif nWindWidth = iif(nParms = 6,nWindWidth,78) && all the way if width not passed nWindWidth = min(nWindWidth,78) && width param > 78 not allowed *-- window width can't be narrower than messsage, so.... nWindWidth = iif(lMessage,max(nWindWidth,len(cMessage) + 2),nWindWidth) *-- skip this section if we've been here before *-- this procedure called from inside a loop *-- following section ignored except on first iteration thru loop if type("nTimes") = "U" && check to see if we been here before save screen to sProgBar public nFactor,nTimes && make these available on all iterations nProgLine = iif(set("status") = "ON",20,22) && don't overwrite status *-- determine how wide the window needs to be define window wProgBar from ; nProgLine - iif(lMessage, 2, 1),(80 - (nWindWidth + 2)) / 2 ; to nProgLine + 1,(80 + (nWindWidth + 2)) / 2 - 1 ; double color &cWindCol activate window wProgBar @ 0,0 say replicate(".",nWindWidth - 1) && the ruler @ 0,0 say "0%" && and some gradation %'s @ 0,nWindWidth / 4 - 2 say "25%" @ 0,nWindWidth / 2 - 2 say "50%" @ 0,3*(nWindWidth / 4) - 2 say "75%" @ 0,nWindWidth - 4 say "100%" @ 0,0 fill to 0,nWindWidth - 1 color &cFillCol1 && color of ruler before process if lMessage @ 1,(nWindWidth - (len(cMessage))) / 2 say cMessage color &cFillCol1 @ 1,0 fill to 1,nWindWidth - 1 color &cFillCol1 endif nFactor = nQuan/nWindWidth && e.g. how many records per bar part(cols) nTimes = 0 && times thru loop endif && type("nTimes") = "U" *-- this section will be processed as many times as required by nQuan nTimes = nTimes + 1 @ 0,0 fill to 0,int(nTimes / nFactor) ; - iif(int(nTimes / nFactor) - 1 >= 0, 1, 0) ; color &cFillCol2 && color of ruler as processing takes place if nTimes = nQuan && we done x = inkey(.5) && leave on screen just a liitle while after completion *-- cleanup your mess deactivate window wProgBar release window wProgBar restore screen from sProgBar release screen sProgBar release nProgBar,nFactor,nTimes,lMessage,x endif && nTimes = nQuan RETURN *-- EoP: ProgBar FUNCTION ScrnHead *------------------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 05/23/1991 *-- Notes.......: Displays a heading on the screen in a box 2 *-- spaces wider than the text, with a custom border (double *-- line top, single the rest) *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 4/29/1991 - Modified by Ken Mayer (KENMAYER) to add shadow *-- Calls.......: SHADOW Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: scrnhead("<cColor>","<cText>") *-- Examples....: cDummy = ScrnHead("rg+/gb","Print Financial Report") *-- Returns.....: nul/"" *-- Parameters..: cColor = Colors to display box/text in *-- cText = text to be displayed. *------------------------------------------------------------------------------- parameters cColor,cText private cTextStart,cText2 cText2 = " "+trim(cText)+" " && ad spaces to left and right cTextstart = (80-len(trim(cText2)))/2 do shadow with 1,cTextstart-1,3,81-cTextstart @1,cTextstart-1 to 3,81-cTextstart 205,196,179,179,213,184,192,217; color &cColor. && display box @2, cTextstart say cText2 color &cColor. && display text RETURN "" *-- EoF: ScrnHead() FUNCTION YesNo *------------------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 06/08/1992 *-- Notes.......: Asks a yes/no question in a dialog window/box *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function *-- 04/29/1991 - Modified by Ken Mayer add shadow *-- 05/13/1991 - Modified by Ken Mayer remove need for extra *-- procedures (YES/NO) that were used for returning *-- values from Menu *-- (suggested by Clinton L. Warren (VBCES)) *-- 01/20/1992 - Modified by Martin Leon (HMan) to handle user *-- pressing 'Y' or 'N' keys (with ON KEY ...). *-- 04/22/1992 - Modified by Ken Mayer adding CLEAR TYPEAHEAD, *-- as occaisional problems appear otherwise. *-- 06/08/1992 - Modified (Ken Mayer) to deal with explicit *-- color processing. *-- Calls.......: SHADOW Procedure in PROC.PRG *-- CENTER Procedure in PROC.PRG *-- RECOLOR Procedure in PROC.PRG *-- COLORBRK() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: yesno(<lAnswer>,"<cMess1>","<cMess2>","<cMess3>","<cColor>") *-- Example.....: if YesNo(.t.,"Do You Really Wish To Delete?",; *-- "This will destroy the data"; *-- "in this record."; *-- "rg+/gb,n/w,rg+/gb") *-- delete *-- else *-- skip *-- endif *-- *-- The middle set of colors should be different, as they *-- will be the colors of the YES/NO selections ... *-- Options may be blank by using nul values ("") *-- Returns.....: .t./.f. depending on user's choice from menu *-- Parameters..: lAnswer = default value (Yes or No) for menu *-- cMess1 = First line of Message *-- cMess2 = Second line of message *-- cMess3 = Third line of message *-- cColor = Colors for window/menu/box *------------------------------------------------------------------------------- parameter lAnswer,cMess1,cMess2,cMess3,cColor private nLMargin,nRMargin,lWrap,cCurColor,cTempCol *-- save old colors, and set new ones cCurColor = set("ATTRIBUTES") cTempCol = colorbrk(cColor,1) set color of normal to &cTempCol set color of message to &cTempCol cTempCol = colorbrk(cColor,2) set color of highlight to &cTempCol cTempCol = colorbrk(cColor,3) set color of box to &cTempCol save screen to sYesno define window wYesno from 8,20 to 15,60 double define menu mYesno *-- remove && from MESSAGE option if using or might be used on Mono system define pad pYes of mYesno Prompt "[Yes]" at 5,10 && message "Yes" define pad pNo of mYesno Prompt "[No]" at 5,25 && message "No" on selection pad pYes of mYesno deactivate menu on selection pad pNo of mYesno deactivate menu do shadow with 8,20,15,60 activate window wYesno nLmargin = _lmargin && store system values nRmargin = _rmargin lWrap = _wrap _lmargin = 2 && set local values _rmargin = 38 _wrap = .t. do center with 0,38,"",cMess1 && center the text do center with 2,38,"",cMess2 do center with 3,38,"",cMess3 *-- deal with user pressing 'Y' or 'N' ... on key label Y keyboard IIF( PAD() = "PYES", "", CHR(19) )+chr(13) on key label N keyboard IIF( PAD() = "PNO", "", CHR(4) )+chr(13) *-- otherwise deal with regular "menu" abilities clear typeahead if lAnswer activate menu mYesno pad pYes else activate menu mYesno pad pNo endif *-- clear out ON KEY settings ... on key label Y on key label N _lmargin = nLmargin && reset system values _rmargin = nRmargin _wrap = lWrap deactivate window wYesno release window wYesno restore screen from sYesno release screen sYesno release menu mYesno *-- reset colors do ReColor with cCurColor RETURN iif(pad()="PYES",.t.,.f.) *-- EoF: YesNo() FUNCTION YesNo2 *------------------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 06/08/1992 *-- Notes.......: Asks a yes/no question in a dialog window/box *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function *-- 04/29/1991 - Modified by Ken Mayer add shadow *-- 05/13/1991 - Modified by Ken Mayer remove need for extra *-- procedures (YES/NO) that were used for returning *-- values from Menu *-- (suggested by Clinton L. Warren (VBCES)) *-- 11/15/1991 - Copied YesNo, modified to allow "location" *-- options -- useful for some screens ... *-- 01/20/1992 - Modified by Martin Leon (HMAN) to allow user to *-- press 'Y' or 'N' and have them recognized ... *-- 04/22/1992 - Modified by Ken Mayer adding CLEAR TYPEAHEAD, *-- as occaisional problems appear otherwise. *-- 06/08/1992 - Modified by same for explicit color sets. *-- Calls.......: SHADOW Procedure in PROC.PRG *-- CENTER Procedure in PROC.PRG *-- COLOROF() Function in PROC.PRG *-- COLORBRK() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: yesno2(<lAnswer>,"<cWhere>",; *-- "<cMess1>","<cMess2>","<cMess3>","<cColor>") *-- Example.....: if YesNo2(.t.,"UL","Do You Really Wish To Delete?",; *-- "This will destroy the data"; *-- "in this record."; *-- "rg+/gb,n/w,rg+/gb") *-- delete *-- else *-- skip *-- endif *-- *-- The middle set of colors should be different, as they *-- will be the colors of the YES/NO selections ... *-- Options may be blank by using nul values ("") *-- Returns.....: .t./.f. depending on user's choice from menu *-- Parameters..: lAnswer = default value (Yes or No) for menu *-- cWhere = location on screen: *-- "UL" = Upper Left *-- "UC" = Upper Center *-- "UR" = Upper Right *-- "CL" = Center Left *-- "CC" = Center Center *-- "CR" = Center Right *-- "BL" = Bottom Left *-- "BC" = Bottom Center *-- "BR" = Bottom Right *-- cMess1 = First line of Message *-- cMess2 = Second line of message (may be nul = "") *-- cMess3 = Third line of message (may be nul = "") *-- cColor = Colors for window/menu/box *------------------------------------------------------------------------------- parameter lAnswer,cWhere,cMess1,cMess2,cMess3,cColor private cExact,cW1,cW2,nULB,nBRR,nULC,nBRC,nLMargin,nRMargin,lWrap,; cCurColor,cTempCol cExact = set("EXACT") save screen to sYesno *-- see what the user gave us ... if len(trim(cWhere)) > 0 cW1 = upper(left(cWhere,1)) && first coordinate (vertical) cW2 = upper(right(cWhere,1)) && second coordinate (horizontal) else cW1 = "C" cW2 = "C" endif *-- deal with vertical placement do case case cW1 = "U" nULR = 1 && upper left row nBRR = 8 && bottom right row case cW1 = "C" nULR = 8 nBRR = 15 case cW1 = "B" nULR = 15 nBRR = 22 endcase *-- deal with horizontal placement do case case cW2 = "L" nULC = 5 && upper left column nBRC = 45 && bottom right column case cW2 = "R" nULC = 35 nBRC = 75 case cW2 = "C" nULC = 20 nBRC = 60 endcase *-- save old colors, and set new ones cCurColor = set("ATTRIBUTES") cTempCol = colorbrk(cColor,1) set color of normal to &cTempCol set color of message to &cTempCol cTempCol = colorbrk(cColor,2) set color of highlight to &cTempCol cTempCol = colorbrk(cColor,3) set color of box to &cTempCol define window wYesno from nULR,nULC to nBRR,nBRC double define menu mYesno *-- remove && from MESSAGE option if using or might be used on Mono system define pad pYes of mYesno Prompt "[Yes]" at 5,10 && message "Yes" define pad pNo of mYesno Prompt "[No]" at 5,25 && message "No" on selection pad pYes of mYesno deactivate menu on selection pad pNo of mYesno deactivate menu *-- start displaying it ... shadow, window ... do shadow with nULR,nULC,nBRR,nBRC activate window wYesno *-- store or set some system values nLmargin = _lmargin nRmargin = _rmargin lWrap = _wrap _lmargin = 2 && set local values _rmargin = 38 _wrap = .t. *-- display text do center with 0,38,"",cMess1 && center the text do center with 2,38,"",cMess2 do center with 3,38,"",cMess3 *-- set 'y' or 'n' keys ... on key label Y keyboard IIF( PAD() = "PYES", "", CHR(19) )+chr(13) on key label N keyboard IIF( PAD() = "PNO", "", CHR(4) )+chr(13) clear typeahead if lAnswer activate menu mYesno pad pYes else activate menu mYesno pad pNo endif *-- reset system ... on key label Y on key label N _lmargin = nLmargin _rmargin = nRmargin _wrap = lWrap deactivate window wYesno release window wYesno restore screen from sYesno release screen sYesno release menu mYesno set exact &cExact do ReColor with cCurColor RETURN iif(pad()="PYES",.t.,.f.) *-- EoF: YesNo2() FUNCTION ErrorMsg *------------------------------------------------------------------------------- *-- Programmer..: Ken Mayer (KENMAYER) *-- Date........: 05/23/1991 *-- Notes.......: Display an error message in a Window: *-- ** ERROR [#] ** *-- *-- Message 1 *-- Message 2 *-- Press any key to continue ... *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: SHADOW Procedure in PROC.PRG *-- CENTER Procedure in PROC.PRG *-- ALLTRIM() Function in PROC.PRG *-- COLORBRK() Function in PROC.PRG *-- RECOLOR Procedure in PROC.PRG *-- Called by...: Any *-- Usage.......: ErrorMsg("<cErr>","<cMess1>","<cMess2>","<cColor>") *-- Example.....: lc_Dummy = errormsg("3","This record","already exists!",; *-- "rg+/r,rg+/r,rg+/r") *-- where "errornum" is an error number or nul, *-- message2 and 3 should be 36 characters or less ... *-- Colors should include foreground/background,; *-- foreground/background,foreground/background *-- Returns.....: numeric value of keystroke user presses (cUser) *-- Parameters..: cErr = Error # (can be blank, but use "" for blank) *-- cMess1 = Error message line 1 *-- cMess2 = Error message line 2 *-- cColor = Colors for text/window/border *------------------------------------------------------------------------------- parameters cErr,cMess1,cMess2,cColor private cCursor,cUser,cTempCol,cCurColor save screen to sErr *-- save colors, set new ones cCurColor = set("ATTRIBUTES") cTempCol = colorbrk(cColor,1) set color of normal to &cTempCol cTempCol = colorbrk(cColor,3) set color of box to &cTempCol define window wErr from 8,20 to 15,60 double color &cColor do shadow with 8,20,15,60 activate window wErr cCursor = set("CURSOR") set cursor off if len(trim(cErr)) > 0 && if there's an error number ... do center with 0,38,"","** ERROR "+alltrim(cErr)+" **" else && otherwise, don't display errornumber do center with 0,38,"","** ERROR **" endif do center with 2,38,"",cMess1 do center with 3,38,"",cMess2 do center with 5,38,"","Press any key to continue ..." cUser=inkey(0) set cursor &cCursor deactivate window wErr release window wErr restore screen from sErr release screen sErr *-- reset colors do ReColor with cCurColor RETURN cUser *-- EoF: ErrorMsg() PROCEDURE Shadow *------------------------------------------------------------------------------- *-- Programmer..: Ashton-Tate *-- Date........: 01/27/1992 *-- Notes.......: Creates a shadow for a window (taken from the dBASE IV *-- picklist functions) *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 05/23/1991 - original procedure. *-- 12/14/1991 - Modified by Jim Magnant (TXAGGIE) - to check *-- for columns exceeding 79, and temporarily change last col. *-- value (so routine doesn't "blow up"). *-- 01/27/1992 -- Modifiedy by Ken Mayer to check for bottom *-- of screen, based on what Jim did above. No further than 23. *-- Calls.......: None *-- Called by...: Too many to list ... *-- Usage.......: do shadow with <nULRow>,<nULCol>,<nBRRow>,<nBRCol> *-- Example.....: save screen to sMain *-- define window wError from 5,15 to 15,65 double color; *-- rg+/r,rg+/r,rg+/r *-- do shadow with 5,15,15,65 *-- activate window WError *-- && perform actions in window *-- deactivate window WError *-- release window WError *-- restore screen from sMain *-- release screen sMain *-- Returns.....: None *-- Parameters..: nULRow = Upper Left Row position *-- nULCol = Upper Left Column position (x,y) *-- nBRRow = Bottom Right Row position *-- nBRCol = Bottom Right Column position (x2,y2) *------------------------------------------------------------------------------- parameters nULRow,nULCol,nBRRow,nBRCOL private nTempRow,nTempCol,nIncRow,nIncCol nTempRow = iif(nBRRow+1>23,23,nBRRow+1) nTempCol = iif(nBRCol+2>79,79,nBRCol+2) nIncRow = 1 nIncCol = (nBRCol-nULCol) / (nBRRow-nULRow) do while nTempRow <> nULRow .or. nTempCol <> nULCol+2 nRightCol = nBRCol nBRCol = iif(nBRCol + 2 > 79,77,nBRCol) nBotRow = nBRRow nBRRow = iif(nBRRow + 1 > 23,22,nBRRow) @ nTempRow,nTempCol fill to nBRRow+1,nBRCol+2 color n+/n nBRCol = nRightCol nBRRow = nBotRow nTempRow = iif(nTempRow<>nULRow,nTempRow - nIncRow,nTempRow) nTempCol = iif(nTempCol<>nULCol+2,nTempCol - nIncCol,nTempCol) nTempCol = iif(nTempCol<nULCol+2,nULCol+2,nTempCol) enddo RETURN *-- EoP: Shadow *=============================================================================== * COLOR PROCESSING -- These routines handle setting colors, dealing with * checking how colors are set, and so on. Anything that's not here is in * the library file: COLOR.PRG. *=============================================================================== FUNCTION ExtrClr *------------------------------------------------------------------------------- *-- Programmer..: Ken Mayer (KENMAYER) *-- Date........: 05/24/1991 *-- Notes.......: Used to extract the first parameter of the MEMVARS *-- created from SETCOLOR above. The SET COLOR OF commands can *-- only use the first parameter. *-- It is recommended that you run SetColor (above) first, *-- although if you define your own color memvars, this will work *-- just as well. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: extrclr(<cMemVar>) *-- Example.....: set color of highlight to &extrclr(cl_stand) *-- Returns.....: "W+/B" *-- Parameters..: cMemVar = color memory variable to have colors extracted from *------------------------------------------------------------------------------- parameters cMemVar RETURN substr(cMemVar,1,(at(",",cMemVar)-1)) *-- EoF: ExtrClr() FUNCTION InvClr *------------------------------------------------------------------------------- *-- Programmer..: Ken Mayer (KENMAYER) *-- Date........: 05/23/1991 *-- Notes.......: Used to set an inverse color, using value(s) returned *-- from extrclr above, or from a single color memvar. *-- Inverted colors may give odd results -- RG+ (yellow) is *-- not a background color, for example, and will appear as *-- RG (brown) -- this may not be what you wanted ... *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: invclr(<cMemVar>) *-- Example.....: set color of highlight to &invclr(extrclr(cl_stand)) *-- or *-- x = extrclr(cl_stand) *-- set color of highlight to &invclr(x) *-- Returns.....: "B/W+" *-- Parameters..: cMemVar = color variable containing colors to be inverted *------------------------------------------------------------------------------- parameters cMemVar private cTemp1, cTemp2 cTemp1 = substr(cMemVar,1,(at("/",cMemVar)-1)) cTemp2 = substr(cMemVar,(at("/",cMemVar)+1),len(cMemVar)) RETURN cTemp2+"/"+cTemp1 *-- EoF: InvClr() FUNCTION ColorOf *------------------------------------------------------------------------------- *-- Programmer..: Jay Parsons (JPARSONS) *-- Date........: 01/11/1992 *-- Notes.......: This function will return the color of a specified area *-- (as built in to dBASE). *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: ALLTRIM() Function in PROC.PRG *-- Called by...: Any *-- Usage.......: ColorOf("<cArea>") *-- Example.....: ?ColorOf("Messages") *-- Returns.....: Color (foreground/background) *-- Parameters..: cArea = Area you wish to return the color of from list: *-- BOX/BOXES = Boxes *-- BORDER/PERIMETER = Border color *-- NORMAL = Normal screen/text *-- HIGHLIGHT = Highlights *-- MESSAGE = Messages *-- TITLE = Titles *-- INFORMATION = Information *-- FIELDS = Fields *------------------------------------------------------------------------------- parameters cArea private cAttrib, cWanted, nPos cAttrib = set("ATTRIBUTES") cWanted = upper(alltrim(cArea)) if cWanted = "BOX" nPos = 6 else nPos = at(left(cWanted,4),; " NORM HIGH PERI MESS TITL BOXE INFO FIEL BORD") / 5 if nPos = 9 nPos = 3 && "Border" = "Perimeter" endif endif do case case nPos = 0 cAttrib = "" && return null string for error case nPos < 4 cAttrib = left(cAttrib,at("&",cAttrib) - 2) otherwise cAttrib = substr(cAttrib,at("&",cAttrib) + 3) nPos = nPos - 3 endcase do while nPos > 1 cAttrib = substr(cAttrib,at(",",cAttrib) + 1) nPos = nPos - 1 enddo RETURN left(cAttrib,at(",",cAttrib+",")-1) *-- EoF: ColorOf() PROCEDURE ReColor *------------------------------------------------------------------------------- *-- Programmer..: Jay Parsons (Jparsons) *-- Date........: 04/23/1992 *-- Notes.......: Restores colors to those held in a string of the form *-- returned by set("ATTRIBUTE"). *-- Written for.: dBASE IV, Versions 1.0 - 1.5. *-- Rev. History: None *-- Calls : None *-- Called by...: Any *-- Usage.......: DO ReColor WITH <cColors> *-- Example.....: DO Recolor WITH OldColors *-- Parameters..: cColors, a string in the form returned by set("ATTRIBUTE"). *-- Side effects: Changes the screen colors. *------------------------------------------------------------------------------- parameters cColors private cThis, cNext, nAt, cLeft, nX, cAreas cAreas = " NORMHIGHBORDMESSTITLBOX INFOFIEL" cLeft = cColors + ", " nX = 0 do while nX < 8 nX = nX + 1 cThis = substr( cAreas, 4 * nX, 4 ) if nX = 3 nAt = at( "&", cLeft ) cNext = left( cLeft, nAt - 2 ) cLeft = substr( cLeft, nAt + 3 ) SET COLOR TO , , &cNext else nAt = at( ",", cLeft ) cNext = left( cLeft, nAt - 1 ) cLeft = substr( cLeft, nAt + 1 ) SET COLOR OF &cThis TO &cNext endif enddo RETURN *-- EoP: ReColor FUNCTION ColorBrk *------------------------------------------------------------------------------- *-- Programmer..: Ken Mayer (KENMAYER) *-- Date........: 06/08/1992 *-- Notes.......: This routine is designed to be used with any of my functions *-- and procedures that accept a memory variable for color, *-- and use a window. It's purpose is to break that color var *-- into it's components (depending on which one the user wants) *-- and return those components, so that they can then be used *-- in SET COLOR OF ... commands. *-- Written for.: dBASE IV, 1.1, 1.5 (written because of 1.5, but will work in *-- 1.1) *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: ColorBrk(<cColorVar>,<nField>) *-- Example.....: set color of normal to ColorBrk(cColor,1) *-- Returns.....: Either the field you asked for (1 thru 3) or null string (""). *-- Parameters..: cColorVar = Color variable to extract data from *-- nField = Field you want to extract *------------------------------------------------------------------------------- parameters cColorVar, nField private cReturn, cExtracted do case case nField = 1 cReturn = left(cColorVar,at(",",cColorVar)-1) case nField = 2 cExtract = substr(cColorVar,at(",",cColorVar)+1) && everything to && right of comma cReturn = left(cExtract,at(",",cExtract)-1) && left of second , case nField = 3 cExtract = substr(cColorVar,at(",",cColorVar)+1) cReturn = substr(cExtract,at(",",cExtract)+1) otherwise cReturn = "" endcase RETURN cReturn *-- EoF: ColorBrk() Function VPICK *------------------------------------------------------------------------------- *-- Programmer...: Keith G. Chuvala (KGC) *-- Date.........: 06/02/1992 *-- Notes........: Keith wanted a multiple choice picklist routine for use *-- with a mouse (or other) ... he got the idea for the AT-USER *-- system which he was Beta Testing. Here 'tis ... *-- This creates a quick pick-list for multiple-choice, single- *-- character input. The first letter of the selected bar is *-- returned. If <Esc> is pressed, a null string is returned. *-- NOTE: If using this with dBASE IV, 1.1, you must supply *-- a parameter for each option below. *-- Written for..: dBASE IV, 1.5 *-- Rev. History.: None *-- Calls........: RECOLOR Procedure in PROC.PRG *-- COLORBRK() Function in PROC.PRG *-- Called by....: Any *-- Usage........: ?VPICK(<nRow>,<nCol>,"<cOptions>","<cTitle>","<cMessage>",; *-- <lShadow>,<cColor>) *-- Example......: cHow = VPick(12,15,"~BorBBS~Lastname",; *-- "How do you want the data sorted?","Choose one",; *-- "&clWind1") *-- Returns......: First letter of bar selected, or null if <Esc>. *-- Parameters...: nRow = is a numeric value for the top row of the popup. *-- nCol = is a numeric value for the left column. *-- cOptions = is a string of options with each preceded by *-- '~', e.g. "~Screen~Printer~Text File~Return to Menu" *-- cTitle = is an optional title, used for the popup heading *-- cMessage = is an optional message string for when the popup *-- is activated on the screen. *-- lShadow = is a logical value indicating whether or not a *-- shadow is to be placed under the popup. *-- cColor = Colors to be used ... (uses format: *-- "<Unselected Text>,<SelectedText>,<Border>" where *-- each part above is: <Foreground/Background>, i.e,: *-- "rg+/gb,w+/b,rg+/gb" to get unselected in yellow *-- on Cyan, selected in bright white on blue, and *-- border/box in yellow on cyan.) *------------------------------------------------------------------------------- parameters nRow,nCol,cOptions,cTitle,cMessage,lShadow,cColor private nRow,nCol,cOptions,cTitle,cMessage,lShadow,cCurColor,cBox,cTitles,; cTempCol *-- get number of parameters, and a few setup steps ... if val(right(version(),3)) > 1.1 nParameters = pcount() else nParameters = 7 endif nCount = 0 cReturn = "" cOptions = trim(cOptions) cDispMesg = "" *-- save current colors cCurColor = set("ATTRIBUTES") *-- set new colors cTempCol = colorbrk(cColor,1) set color of message to &cTempCol cTempCol = colorbrk(cColor,2) set color of highlight to &cTempCol cTempCol = colorbrk(cColor,3) set color of box to &cTempCol *-- if number of parameters greater/equal to 5, we may have a message *-- at the bottom of the screen ... if nParameters >= 5 if len(cMessage) > 0 cDispMesg = "MESSAGE "+"'"+cMessage+"'" endif endif *-- define the popup define popup pPickList from nRow,nCol &cDispMesg. nMessage1 = 0 *-- if we have 4 or more parameters, one of them is the title ... *-- this requires that the first two bars of the menu be skipped ... if nParameters >= 4 if len(cTitle) > 0 cTitle = " "+cTitle+" " nMessage1 = len(cTitle) nCount = 2 endif endif *-- now we start parsing the options for the menu. These must have *-- a tilde between each, so we look for the first one, and then *-- look again to see if there's another after that. nPos1 = at("~",cOptions) && Look for first tilde do while (len(cOptions) > 0) .and. (nPos1 > 0) && parsing loop ... if nPos1 > 0 cSub = substr(cOptions,nPos1+1,len(cOptions)-nPos1) nPos2 = at("~",cSub) if nPos2 = 0 nPos2 = len(cSub) else nPos2 = nPos2 - 1 endif cOptString = " "+left(cSub,nPos2)+" " if len(cOptString) > nMessage1 nMessage1 = len(cOptString) endif *-- define the actual 'bar' of the menu/picklist ... nCount = nCount + 1 define bar nCount of pPickList prompt cOptString cOptions = cSub endif nPos1 = at("~",cOptions) enddo && end of parsing loop *-- now we deal with defining the actual picklist ... if nCount > 0 && if we have something to put in the list ... if nParameters >= 4 && if we have a title for the top ... if len(cTitle) > 0 if len(cTitle) < nMessage1 cTitle = trim(ltrim(cTitle)) cTitle = space((nMessage1-len(cTitle)) / 2) + cTitle endif define bar 1 of pPickList prompt cTitle skip define bar 2 of pPickList prompt replicate(chr(196),nMessage1) skip endif endif *-- define what to do when a choice is made ... on selection popup pPickList deactivate popup *-- if we have a shadow, let's save screen and do the shadow *-- before popping up the picklist if nParameters => 6 if lShadow save screen to sPickScr @ nRow+1,nCol+2 fill to nRow+nCount+2,nCol+nMessage1+3 color w/n endif else lShadow = .f. endif *-- there we are ... activate popup pPickList *-- cleanup if lShadow restore screen from sPickScr release screen sPickScr endif *-- deal with what to 'return' ... if lastkey() = 27 cReturn = "" else cReturn = substr(prompt(),2,1) endif endif && nCount > 0 *-- we're done with it ... return it back to the electronic byte storage *-- bins ... release popup pPickList *-- reset colors ... do ReColor with cCurColor RETURN cReturn *-- EoF: VPick() *=============================================================================== * STRING Manipulation. Most of these are in the library file: STRINGS.PRG * The ones here are common to a lot of apps and functions, and are here so * that the library STRINGS.PRG need not be called. *=============================================================================== FUNCTION AllTrim *------------------------------------------------------------------------------- *-- Programmer..: Phil Steele (from PCSDEMO.PRG -- Public Domain) *-- Date........: 5/23/1991 *-- Notes.......: Complete trims edges of field (left and right) *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: alltrim(<cString>) *-- Example.....: ? alltrim(" Test String ") *-- Returns.....: Trimmed string, i.e.:"Test String" *-- Parameters..: cString = string to be trimmed *------------------------------------------------------------------------------- parameters cString RETURN ltrim(rtrim(cString)) *-- EoF: AllTrim() FUNCTION State *------------------------------------------------------------------------------- *-- Programmer..: David G. Franknbach (FRNKNBCH) *-- Date........: 04/22/1992 *-- Notes.......: Validation of state codes -- used to ensure that a user *-- doing data entry will enter the proper codes. Added a few *-- US Territory codes as well (Puerto Rico, etc.) *-- Written for.: dBASE IV, 1.1 *-- Rev. History: 12/02/1991 *-- 03/11/1992 -- Modified by Ken Mayer (KENMAYER) to handle *-- the extra US Territories, and to ensure that the data is *-- at least temporarily in upper case when doing the check ... *-- 04/22/1992 -- Modified by Jay Parsons (JPARSONS) to shorten *-- (simplify) the routine by removing the cSTATE2 memvar. *-- Calls.......: None *-- Called by...: None *-- Usage.......: STATE(<cState>) *-- Example.....: @5,10 get cState valid required state(cState); *-- error chr(7)+"This is not a valid state code!" *-- Returns.....: Logical (.t. if found, .f. otherwise) *-- Parameters..: cState = state code to be checked .... *------------------------------------------------------------------------------- parameters cState cStateList = "AL|AK|AZ|AR|CA|CO|CT|DE|DC|FL|GA|HI|ID|IL|IN|IA|KS|KY|LA|"+; "ME|MD|MA|MI|MN|MS|MO|MT|NE|NV|NH|NJ|NM|NY|NC|ND|OH|OK|OR|"+; "PA|RI|SC|SD|TN|TX|UT|VT|VA|WA|WV|WI|WY|PR|AS|GU|CM|TT|VI| " lOK = upper(cState) $ cStateList RETURN lOK *-- EoF: State() *=============================================================================== * DATE HANDLING ROUTINES -- Most of these are now in the library file: * DATES.PRG (included with this version of PROC). However, a few are below, * as they have become 'standard' routines in many of my systems. *=============================================================================== FUNCTION DateText *------------------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 05/23/1991 *-- Notes.......: Display date in format Month, day year (e.g., July 1,1991) *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: DateText(<dDate>) *-- Example.....: ? datetext(date()) *-- Returns.....: July 1, 1991 *-- Parameters..: dDate = date to be converted *------------------------------------------------------------------------------- parameters dDate RETURN CMONTH(dDate)+" "+ltrim(str(day(dDate),2))+", "+str(year(dDate),4) *-- EoF: DateText() FUNCTION DateText2 *------------------------------------------------------------------------------- *-- Programmer..: Miriam Liskin *-- Date........: 05/23/1991 *-- Notes.......: Display date in format day-of-week, Month day, year *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: DateText2(<dDate>) *-- Example.....: ? DateText2(date()) *-- Returns.....: Thursday, July 1, 1991 *-- Parameters..: dDate = date to be converted *------------------------------------------------------------------------------- parameters dDate RETURN CDOW(dDate)+", "+cmonth(dDate)+" "+; ltrim(str(day(dDate),2))+", "+str(year(dDate),4) *-- EoF: DateText2() *=============================================================================== * FIELD HANDLING ROUTINES -- Unique searches, string manipulation ... * The ones left in PROC.PRG are the more commonly used ones. Anything else is * in the library file: FIELDS.PRG. *=============================================================================== FUNCTION IsUnique *------------------------------------------------------------------------------- *-- Programmer..: Clinton L. Warren (VBCES) *-- Date........: 04/28/1992 *-- Notes.......: Checks to see if an index key already exists in the current *-- selected database. This function was inspired by Tom *-- Woodward's Chk4Dup UDF. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: May 15, 1991 Version 1.1 Added check for zero record database *-- May 7, 1991 Version 1.0 Initial 'release'. *-- 04/28/1992 -- modified for dBASE IV, 1.5 due to 'new' *-- behavior (see READ.ME that comes with 1.5). Should function *-- fine with 1.1 and 1.0. This change from David Love (DAVIDLOVE). *-- NOTE: NEW PARAMETER *-- Calls.......: None *-- Called by...: Any *-- Usage.......: IsUnique(<xValue>,"<cOrder>","<cField>") *-- Example.....: @5,5 SAY "SSN: " GET SSN PICTURE "999-99-9999"; *-- valid required IsUnique(SSN, "SSN", "SSN"); *-- message "Enter a new SSN"; *-- error chr(7)+"SSN must be unique!" *-- Returns.....: .T./.F. *-- Parameters..: xValue = Value (any non-memo type) to check for uniqueness *-- cOrder = MDX Tag used to order the database. Must be set for *-- field being checked. *-- cField = field name for 'get'. *------------------------------------------------------------------------------- parameters xValue, cOrder, cField private nRecNo, nRecCnt, cSetNear, cSetDel, lIsDeleted, cSetOrder private lIsUnique nRecNo = recno() && store current record number nRecCnt = reccount() && count records in database if nRecCnt = 0 && empty database, cValue MUST be unique return .t. endif cSetNear = set('NEAR') && store status of NEAR flag set near off && set it off cSetDel = set('DELETE') && store status of DELETE set delete on && Delete must be ON for this to work lIsDeleted = deleted() && is current record deleted? delete && set delete flag for current record cSetOrder = order() && store current MDX tag set order to (cOrder) && set tag to that sent to function if seek(xValue) && does it exist already? lIsUnique = .f. && if so, it's not unique else && otherwise, lIsUnique = .t. && it is. endif set order to (cSetOrder) && restore changed settings to original settings set delete &cSetDel set near &cSetNear if nRecNo > nRecCnt && if called during an append go bottom && goto the bottom of the database, skip 1 && plus one record (the new one) if lIsUnique && this is the new part ... replace &cField with xValue endif else go nRecNo && otherwise, goto the current record number endif if .not. lIsDeleted && was record 'deleted' before? recall && if not, undelete it ... (turn flag off) endif RETURN (lIsUnique) *-- EoF: IsUnique() FUNCTION MemoPagr *------------------------------------------------------------------------------- *-- Programmer..: Martin Leon (HMAN - ATBBS/Borland BBS) *-- Date........: 10/28/91 *-- Notes.......: Used to display a memo on screen, allowing user to scroll *-- memo at will. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: ?MemoPagr(<cMemo>,<ULRow>,<ULCol>,<BRRow>,<BRCol>) *-- Example.....: ?MemoPagr(MoreData,10,20,20,65) *-- Returns.....: .F. *-- Parameters..: cMemo = name of memo field *-- nULRow = upper left row position *-- nULCol = upper left column position *-- nBRRow = bottom right row position *-- nBRCol = bottom right column position *------------------------------------------------------------------------------- PARAMETER cMemo, nULRow, nULCol, nBRRow, nBRCol private cCursor, nEsc, nPgDn, nPgUp, nUp, nDn, nNumLines,nLines,nKey private nAtLine,nAtRow *-- set environment set memowidth to nBRCol - nULCol - 1 cCursor = set( "CURSOR" ) set cursor off *-- define a few keys nEsc = 27 nPgDn = 3 nPgUp = 18 nUp = 5 nDn = 24 *-- determine size of window nNumLines = memlines(&cMemo) nLines = nBRRow - nULRow - 1 *-- save the screen, so we can restore it save screen to sTmp @ nULRow+1, nULCol+1 clear to nBRRow+1, nBRCol+1 @ nULRow+1, nULCol+1 fill to nBRRow+1, nBRCol+1 color B/N @ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 color RG+/B @ nULRow, nULCol to nBRRow, nBRCol double color RG+/B *-- deal with a blank memo ... if nNumLines = 0 @ nULRow + 1, nULCol + 1 SAY ; "Blank Memo. Press any key to continue..." color RG+/B nKey = inkey(0) *-- reset the whole thing restore screen from sTmp release screen sTmp set cursor &cCursor RETURN .F. endif nAtLine = 1 nAtRow = 1 do while nAtLine <= nNumLines *-- Show one window full do while nAtRow <= nLines .and. nAtLine <= nNumLines @ nULRow+nAtRow, nULCol + 1 say ; mline( &cMemo, nAtLine ) color RG+/B nAtLine = nAtLine + 1 nAtRow = nAtRow + 1 enddo *-- If at last line of memo... if nAtLine > nNumLines *-- If memo is shorter than one page, put box character in *-- bottom left corner of box, otherwise, put an up arrow *-- symbol there. @ nBRRow - 1, nBRCol SAY ; iif( nNumLines <= nLines, chr(186), chr(24)) color W+/B do while .T. nKey = inkey(0) *-- If memo is shorter than one page, only allow Esc key if nNumLines <= nLines if nKey = nEsc exit endif *-- Otherwise, allow Esc or PgUp keys else if nKey = nEsc .or. nKey = nPgUp .or. nKey = nUp exit endif endif ?? chr(7) enddo if nKey = nEsc restore screen from sTmp release screen sTmp set cursor &cCursor RETURN .F. endif @ nULRow+1, nULCol+1 clear to nBRRow-1, nBRCol-1 @ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 ; color RG+/B nAtLine = nAtLine - nAtRow - nLines + 1 nAtLine = iif( nAtLine < 1, 1, nAtLine ) nAtRow = 1 loop endif *-- Not at end of memo yet... *-- If on first page, show down arrow only, otherwise show *-- up/down arrow on border of box. @ nBRRow - 1, nBRCol say ; iif( nAtLine - nLines = 1, chr(25), chr(18)) color W+/B do while .T. nKey = inkey(0) *-- If this is the first page of the memo on screen... if nAtLine - nLines = 1 *-- Only honor PgDn, up cursor, and Esc keys if nKey = nPgDn .or. nKey = nDn .or. nKey = nEsc exit endif *-- otherwise honor PgUp and up cursor as well key as well else if nKey = nPgUp .or. nKey = nUp .or. nKey = nPgDn .or. ; nKey = nDn .or. nKey = nEsc exit endif endif ?? chr(7) enddo do case case nKey = nEsc restore screen from sTmp release screen sTmp set cursor &cCursor RETURN .F. case nKey = nPgUp .or. nKey = nUp @ nULRow+1, nULCol+1 clear to nBRRow-1, nBRCol-1 @ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 ; color RG+/B nAtLine = (nAtLine - (2 * nLines)) nAtLine = IIF( nAtLine < 1, 1, nAtLine ) nAtRow = 1 loop case nKey = nPgDn .or. nKey = nDn @ nULRow+1, nULCol+1 clear to nBRRow-1, nBRCol-1 @ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 ; color RG+/B nAtRow = 1 loop endcase enddo RETURN .F. *-- EoF: MemoPagr() *=============================================================================== * MISC ROUTINES -- Ones that don't fit into other categories, quite ... but * are none-the-less very useful ... many of these routines have been placed * in the library file: MISC.PRG. *=============================================================================== FUNCTION IsMouse *------------------------------------------------------------------------------- *-- Programmer..: Ken Mayer (KENMAYER) *-- Date........: 06/18/1992 *-- Notes.......: This is used to determine the presence of a mouse driver. *-- Returns a .t. if a mouse driver is detected, a .f. otherwise. *-- This routine will turn the mouse off, automatically. This *-- can be used to detect a mouse, and turn it off, as well *-- as to set a memvar to determine the current mouse state. *-- For example, after running this routine, the mouse will be *-- off (if there's a driver). *-- ****************************** *-- **** REQUIRES JPMOUSE.BIN **** *-- ****************************** *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: IsMouse() *-- Example.....: ?IsMouse() *-- Returns.....: Logical *-- Parameters..: None *------------------------------------------------------------------------------- private cRetVal, lIsMouse, X Load JPMOUSE.BIN cRetVal = call("JPMOUSE","?") lIsMouse = iif(cRetVal="T",.t.,.f.) if lIsMouse x = call("JPMOUSE","H") endif release module JPMOUSE RETURN lIsMouse *-- EoF: IsMouse() PROCEDURE SetMouse *------------------------------------------------------------------------------- *-- Programmer..: Ken Mayer (KENMAYER) *-- Date........: 06/18/1992 *-- Notes.......: This is used to determine the presence of a mouse driver, *-- and/or turn the mouse cursor off in dBASE IV, 1.5 *-- ****************************** *-- **** Requires JPMOUSE.BIN **** *-- ****************************** *-- Written for.: dBASE IV, 1.5 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: Do SetMouse with <c_Mouse> *-- Example.....: PUBLIC c_Mouse *-- x=ismouse() && function in MISC.PRG *-- store "OFF" to c_Mouse && after calling IsMouse() it's 'Off' *-- ON KEY LABEL Alt-M DO SetMouse *-- Returns.....: .T. *-- Parameters..: c_Mouse = A GLOBAL memory variable -- this can/will be changed *-- by this procedure to the opposite scenario when the *-- routine is called. The concept here is to switch *-- the mouse on and/or off if there's a mouse driver. *-- This memvar should be set to the current status of the mouse- *-- if on, it should hold "ON" in it ... *------------------------------------------------------------------------------- private X if type("C_MOUSE") # "C" && if c_Mouse has not been defined as return && a character field, return endif load JPMOUSE.BIN && load the module *-- if the mouse is off, we're going to set it on ("S"), if on, we're *-- going to set it off "H") cSetMouse = iif(upper(c_Mouse) = "OFF","S","H") x=call("JPMOUSE",cSetMouse) release module JPMOUSE && remove from memory *-- if c_Mouse was 'off' we are setting it 'on', and vice versa c_Mouse = iif(upper(c_Mouse) = "OFF","ON","OFF") && change state of c_Mouse RETURN *-- EoP: SetMouse FUNCTION IsBlank *------------------------------------------------------------------------------- *-- Programmer..: Jerry Wightman (WIGHTMAN) *-- Date........: ? *-- Notes.......: Used to check whether a memory variable in dBASE contains *-- anything, based on type of field. (Pulled from BORBBS) *-- NOTE: In release 1.5, replace all calls to EMPTY() with *-- the new: ISBLANK() function. This will be faster. *-- Renamed for use here to ISBLANK(), for compatibilities' sake. *-- Written for.: dBASE IV, 1.1 *-- Rev. History: None *-- Calls.......: None *-- Called by...: Any *-- Usage.......: IsBlank(<cFld>) *-- Example.....: @5,10 say "Enter date: " get bDate; *-- valid required .not. IsBlank(bDate); *-- error chr(7)+"** Date cannot be Empty! **" *-- Returns.....: Logical (.t./.f.) *-- Parameters..: cFld = Field/Memvar/Expression to check for "Emptiness" *------------------------------------------------------------------------------- PARAMETERS cFld && may be memory variable or database field name private cTalk, lReturn cTalk = SET("TALK") lReturn = .F. && FALSE means: variable is NOT empty do case case type( "cFld" ) = "C" if len( ltrim(rtrim( cFld )) ) = 0 lReturn = .T. endif case type( "cFld" ) = "N" .or. type( "cFld" ) = "F" if cFld = 0 lReturn = .T. endif case type( "cFld" ) = "L" lReturn = .F. && Can't check logical fields case type( "cFld" ) = "D" if cFld = {} lReturn = .T. endif case type( "cFld" ) = "M" if len( cFld ) = 0 lReturn = .T. endif otherwise && TYPE = "U" lReturn = .T. endcase set talk &cTalk RETURN lReturn *-- EoF: IsBlank() *=============================================================================== *-- End of Procedure File -- PROC.PRG *===============================================================================